home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / TCPOOExample / TCP Libraries / TCPStuff.unit < prev    next >
Encoding:
Text File  |  1993-06-30  |  29.5 KB  |  1,021 lines  |  [TEXT/PJMM]
  1. unit TCPStuff;
  2.  
  3. { TCPStuff © Peter Lewis, Oct 1991 }
  4. { This source is Freeware }
  5.  
  6. interface
  7.  
  8.     uses
  9.         TCPTypes;
  10.  
  11.     const
  12.         Minimum_TCPBufferSize = 4096;
  13.         Default_TCPBufferSize = longInt(6) * 1024;
  14.     { Amount of space to allocate for each TCP connection }
  15.         INCOMINGBUFSIZE = 100;    { Incoming buffer size, used for buffering ReceiveUpTo. }
  16.         control_block_max = 260;
  17.         tooManyControlBlocks = -23098;
  18.         Default_UDPBufferSize = 4048;
  19.  
  20.     type
  21.         OSErrPtr = ^OSErr;
  22.  
  23. { TCP connection description: }
  24.         TCPConnectionType = record
  25.                 magic: OSType;    { A magic number to try and avoid problems with released connection IDs. }
  26.                 stream: StreamPtr;
  27.                 closedone: boolean;
  28.                 laststate: integer;
  29.                 asends, asendcompletes: longInt;
  30.                 closeuserptr: OSErrPtr;
  31.                 incomingPtr: Ptr;                                { Pointer into inBuf of next byte to read. }
  32.                 incomingSize: longInt;                        { Number of bytes left in inBuf. }
  33.                 buffer: ptr;        { connection buffer. }
  34.                 inBuf: array[1..INCOMINGBUFSIZE] of SignedByte;    {Input buffer. }
  35.             end;
  36.         TCPConnectionPtr = ^TCPConnectionType;
  37.  
  38.         MyControlBlock = record
  39.                 tcp: TCPControlBlock;
  40.                 inuse: boolean;
  41.                 userptr: OSErrPtr;
  42.                 proc: procPtr;
  43.                 tcpc: TCPConnectionPtr;
  44.             end;
  45.         MyControlBlockPtr = ^MyControlBlock;
  46.  
  47.  
  48.         TCPStateType = (T_WaitingForOpen, T_Closed, T_Listening, T_Opening, T_Established,{}
  49.             T_Closing, T_PleaseClose, T_Unknown);
  50.  
  51.     type
  52.         UDPConnectionRecord = record
  53.                 magic: OSType;    { A magic number to try and avoid problems with released connection IDs. }
  54.                 stream: StreamPtr;
  55.                 outstanding: integer;
  56.             end;
  57.         UDPConnectionPtr = ^UDPConnectionRecord;
  58.         IPControlBlockPtr = ^IPControlBlock;
  59.  
  60.     var
  61.         icmp_sent_out, icmp_got_back: longInt;
  62.  
  63.     function TCPNameToAddr (var hostName: str255; timeout: longInt): longInt;
  64.     function TCPOpenResolver (var dataptr: ptr): OSErr;
  65.     function TCPStrToAddr (dataptr: ptr; var hostName: str255; var rtnStruct: hostInfo; var done: signedByte): OSErr;
  66.     procedure TCPAddrToStr (dataptr: ptr; addr: longInt; var addrStr: str255);
  67.     function TCPAddrToName (dataptr: ptr; addr: longInt; var rtnStruct: hostInfo; var done: signedByte): OSErr;
  68.     procedure TCPCloseResolver (dataptr: ptr);
  69.  
  70.     function C2PStr (s: stringPtr): stringPtr;
  71.     procedure SanitizeHostName (var s: str255);
  72.  
  73.     function TCPInit: OSErr;
  74.     procedure TCPFinish;
  75.     function TCPActiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
  76.     function TCPPassiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
  77.     function TCPCreateConnectionForStream (var connection: TCPConnectionPtr; strm: streamPtr): OSErr;
  78.     function TCPFlush (connection: TCPConnectionptr): OSErr;
  79.     function TCPClose (connection: TCPConnectionPtr; userptr: OSErrPtr): OSErr;
  80.     function TCPAbort (connection: TCPConnectionPtr): OSErr;
  81.     function TCPRelease (var connection: TCPConnectionPtr): OSErr;
  82.     procedure TCPRawState (connection: TCPConnectionPtr; var state: integer; var localhost: longInt; var localport: integer; var remotehost: longInt; var remoteport: integer; var available: longInt);
  83.     function TCPState (connection: TCPConnectionPtr): TCPStateType;
  84.     function TCPCharsAvailable (connection: TCPConnectionPtr): longInt;
  85.     function TCPLocalPort (connection: TCPConnectionPtr): integer;
  86.     function TCPRawReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
  87. { Use EITHER RawReceive, or the other Receives.  Don't combine them for one stream! }
  88.     function TCPReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
  89.     function TCPReadByte (connection: TCPConnectionPtr; timeout: longInt; var b: SignedByte): OSErr;
  90.     function TCPReceiveUpTo (connection: TCPConnectionPtr; termChar: signedByte;{}
  91.                                     charTimeOut: longInt; readPtr: ptr; readSize: longInt; var readPos: longInt;{}
  92.                                     var gottermchar: boolean): OSErr;
  93.     function TCPSend (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean): OSErr;
  94.     function TCPSendAsync (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean; userptr: OSErrPtr): OSErr;
  95.  
  96.     function UDPCreate (var connection: UDPConnectionPtr; buffer_size: longInt; var localport: integer): OSErr;
  97.     function UDPRead (connection: UDPConnectionPtr; timeout: integer; var remoteIP: longInt; var remoteport: integer;{}
  98.                                     var datap: ptr; var datalen: integer): OSErr;
  99.     function UDPReturnBuffer (connection: UDPConnectionPtr; datap: ptr): OSErr;
  100.     function UDPDatagramsAvailable (connection: UDPConnectionPtr): integer;
  101.     function UDPWrite (connection: UDPConnectionPtr; remoteIP: longInt; remoteport: integer;{}
  102.                                     datap: ptr; datalen: integer; checksum: boolean): OSErr;
  103.     function UDPRelease (var connection: UDPConnectionPtr): OSErr;
  104.     function UDPMTU (remoteIP: longInt; var mtu: integer): OSErr;
  105.  
  106.     function IPGetMyIPAddr (var myIP: longInt): OSErr;
  107.     function IPSendICMPEcho (remotehost: ipAddr; timeout: integer; datap: ptr; datalen: integer; complete: ProcPtr; userdata: univ ptr; extradata: univ ptr): OSErr;
  108. {procedure ICMPCompletion (cbp: IPControlBlockPtr; userdata: ptr;extradata:ptr);}
  109.  
  110.     procedure ZeroCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
  111.  
  112.  
  113. implementation
  114.  
  115.     const
  116.         MAGICNUMBER = 'TMGK';    { Unique value used to trap illegal connection IDs. }
  117.         UDPMagic = 'UDPM';
  118.         UDPBad = '????';
  119.         dispose_block_max = 100;
  120.  
  121.     type
  122.         MyControlBlockArray = array[1..control_block_max] of MyControlBlockPtr;
  123.  
  124.     var
  125.         driver_refnum: integer;
  126.         controlblocks: MyControlBlockArray;
  127.         disposeblocks: array[1..dispose_block_max] of ptr;
  128.  
  129.     const
  130.         max_ICMPDataArray = 100;
  131.     type
  132.         ICMPData = record
  133.                 complete: ProcPtr;
  134.                 userdata: ptr;
  135.                 extradata: ptr;
  136.             end;
  137.         ICMPDataArray = array[1..max_ICMPDataArray] of ICMPData;
  138.     var
  139.         icmp_data_array: ICMPDataArray;
  140.  
  141.     procedure SanitizeHostName (var s: str255);
  142.         var
  143.             dummysp: stringPtr;
  144.     begin
  145.         dummysp := C2PStr(@s);
  146. {$PUSH}
  147. {$R-}
  148.         if s[Length(s)] = '.' then
  149.             s[0] := chr(Length(s) - 1);
  150. {$POP}
  151.     end;
  152.  
  153.     function GetA6: Ptr;
  154.     inline
  155.         $2E8E;
  156.  
  157.     procedure CallCompletion (cbp: MyControlBlockPtr; addr: procPtr);
  158.     inline
  159.         $205F, $4E90;
  160.  
  161. {$PUSH}
  162. {$D-}
  163.     procedure IOCompletion; { All C functions look like pascal paramterless procedures from the procs point of view }
  164.         type
  165.             stackframe = packed record
  166.                     frameptr: ptr;
  167.                     returnptr: ptr;
  168.                     paramblockptr: MyControlBlockPtr;
  169.                 end;
  170.             stackframeptr = ^stackframe;
  171.         var
  172.             a6: stackframeptr;
  173.             cbp: MyControlBlockPtr;
  174.     begin
  175.         a6 := stackframeptr(GetA6);
  176.         cbp := a6^.paramblockptr;
  177.         with cbp^ do begin
  178.             if userptr <> nil then
  179.                 userptr^ := cbp^.tcp.ioResult;
  180.             inuse := false;
  181.             if proc <> nil then
  182.                 CallCompletion(cbp, proc);
  183.         end;
  184.     end;
  185.  
  186.     procedure ZotBlocks;
  187.         var
  188.             i: integer;
  189.     begin
  190.         for i := 1 to dispose_block_max do begin
  191.             if disposeblocks[i] <> nil then begin
  192.                 DisposePtr(disposeblocks[i]);
  193.                 disposeblocks[i] := nil;
  194.             end;
  195.         end;
  196.     end;
  197.  
  198.     procedure AddBlock (p: univ ptr);
  199. { Called at interupt level }
  200. { Must work even while ZotBlocks is in progress }
  201.         var
  202.             i: integer;
  203.     begin
  204.         for i := 1 to dispose_block_max do begin
  205.             if disposeblocks[i] = nil then begin
  206.                 disposeblocks[i] := p;
  207.                 leave;
  208.             end;
  209.         end;
  210.     end;
  211.  
  212.     procedure ZeroCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
  213.     { Zero out the control block parameters. }
  214.         var
  215.             i: integer;
  216.             p: longInt;
  217.     begin
  218.         ZotBlocks;
  219.         for p := longInt(@cb) to longInt(@cb) + SizeOf(TCPControlBlock) - 1 do
  220.             ptr(p)^ := 0;
  221.         cb.tcpStream := stream;
  222.         cb.ioCRefNum := driver_refnum;
  223.         cb.csCode := call;
  224.     end;
  225.  
  226.     function GetCB (var cbp: MyControlBlockPtr; tcpc: TCPConnectionPtr; call: integer; userptr: OSErrPtr; proc: procptr): OSErr;
  227. { NOTE: Must not move memory if there is a free block available (ie, during a Completion call) }
  228.         var
  229.             i: integer;
  230.     begin
  231.         i := 1;
  232.         while (i < control_block_max) & (controlblocks[i] <> nil) & controlblocks[i]^.inuse do
  233.             i := i + 1;
  234.         cbp := controlblocks[i];
  235.         if cbp = nil then begin
  236.             cbp := MyControlBlockPtr(NewPtr(SizeOf(MyControlBlock)));
  237.             if cbp <> nil then begin
  238.                 cbp^.inuse := false;
  239.                 controlblocks[i] := cbp;
  240.             end;
  241.         end;
  242.         if (cbp <> nil) & not cbp^.inuse then begin
  243.             ZeroCB(cbp^.tcp, tcpc^.stream, call);
  244.             cbp^.tcp.ioCompletion := @IOCompletion;
  245.             cbp^.inuse := true;
  246.             cbp^.userptr := userptr;
  247.             cbp^.tcpc := tcpc;
  248.             cbp^.proc := proc;
  249.             if userptr <> nil then
  250.                 userptr^ := inprogress;
  251.             GetCB := noErr;
  252.         end
  253.         else begin
  254.             cbp := nil;
  255.             GetCB := memFullErr;
  256.         end;
  257.     end;
  258.  
  259.     procedure FreeCB (var cbp: MyControlBlockPtr);
  260.     begin
  261.         if cbp <> nil then
  262.             cbp^.inuse := false;
  263.         cbp := nil;
  264.     end;
  265. {$POP}
  266.  
  267. {$S Init}
  268.     function TCPInit: OSErr;
  269.         var
  270.             oe: OSErr;
  271.             i: integer;
  272.     begin
  273.         oe := OpenDriver('.IPP', driver_refnum);
  274.         for i := 1 to control_block_max do
  275.             controlblocks[i] := nil;
  276.         for i := 1 to max_ICMPDataArray do
  277.             icmp_data_array[i].complete := nil;
  278.         TCPInit := oe;
  279.     end;
  280.  
  281. {$S Term}
  282.     procedure TCPFinish;
  283.         var
  284.             i: integer;
  285.     begin
  286.         for i := 1 to control_block_max do
  287.             if controlblocks[i] <> nil then begin
  288.                 DisposPtr(ptr(controlblocks[i]));
  289.                 controlblocks[i] := nil;
  290.             end;
  291.     end;
  292.  
  293. {$S}
  294.     procedure DestroyConnection (var connection: TCPConnectionPtr);
  295.     begin
  296.         connection^.magic := '????';
  297.         if connection^.buffer <> nil then
  298.             DisposPtr(ptr(connection^.buffer));
  299.         DisposPtr(Ptr(connection));
  300.         connection := nil;
  301.     end;
  302.  
  303.     function ValidateConnection (connection: TCPConnectionPtr): OSErr;
  304.     begin
  305.         if connection = nil then
  306.             ValidateConnection := connectionDoesntExist
  307.         else if connection^.magic <> MAGICNUMBER then
  308.             ValidateConnection := connectionDoesntExist
  309.         else
  310.             ValidateConnection := noErr;
  311.     end;
  312.  
  313. {$PUSH}
  314. {$D-}
  315.     function MyPBControlAsync (var cbp: MyControlBlockPtr): OSErr;
  316.         var
  317.             oe: OSErr;
  318.     begin
  319.         oe := PBControlAsync(ParmBlkPtr(cbp));
  320.         if oe <> noErr then
  321.             FreeCB(cbp);
  322.         MyPBControlAsync := oe;
  323.     end;
  324. {$POP}
  325.  
  326.     procedure SetUserPtr (userptr: OSErrPtr; oe: OSErr);
  327.     begin
  328.         if userptr <> nil then begin
  329.             if oe <> noErr then
  330.                 userptr^ := oe;
  331.         end;
  332.     end;
  333.  
  334.     function TCPCreateConnectionForStream (var connection: TCPConnectionPtr; strm: streamPtr): OSErr;
  335.         var
  336.             oe: OSErr;
  337.     begin
  338.         connection := TCPConnectionPtr(NewPtr(sizeof(TCPConnectionType)));
  339.         if connection = nil then
  340.             oe := memFullErr
  341.         else begin
  342.             oe := noErr;
  343.             with connection^ do begin
  344.                 buffer := nil;
  345.                 magic := MAGICNUMBER;
  346.                 asends := 0;
  347.                 asendcompletes := 0;
  348.                 closedone := false;
  349.                 incomingSize := 0;
  350.                 stream := strm;
  351.             end;
  352.         end;
  353.         if (oe <> noErr) and (connection <> nil) then
  354.             DestroyConnection(connection);
  355.         TCPCreateConnectionForStream := oe;
  356.     end;
  357.  
  358.     function CreateStream (var connection: TCPConnectionPtr; buffersize: longInt): OSErr;
  359.         var
  360.             oe: OSErr;
  361.             cb: TCPControlBlock;
  362.     begin
  363.         if buffersize = 0 then
  364.             buffersize := Default_TCPBufferSize;
  365.         connection := TCPConnectionPtr(NewPtr(sizeof(TCPConnectionType)));
  366.         if connection = nil then
  367.             oe := memFullErr
  368.         else
  369.             with connection^ do begin
  370.                 buffer := NewPtr(buffersize);
  371.                 if buffer = nil then begin
  372.                     oe := memFullErr;
  373.                     DisposPtr(ptr(connection));
  374.                     connection := nil;
  375.                 end
  376.                 else begin
  377.                     magic := MAGICNUMBER;
  378.                     asends := 0;
  379.                     asendcompletes := 0;
  380.                     closedone := false;
  381.                     incomingSize := 0;
  382.                     ZeroCB(cb, nil, TCPcsCreate);
  383.                     cb.create.rcvBuff := buffer;
  384.                     cb.create.rcvBuffLen := buffersize;
  385.                     oe := PBControlSync(@cb);
  386.                     stream := cb.tcpStream;
  387.                 end;
  388.             end;
  389.         if (oe <> noErr) and (connection <> nil) then
  390.             DestroyConnection(connection);
  391.         CreateStream := oe;
  392.     end;
  393.  
  394.     function PAOpen (var connection: TCPConnectionPtr; cs: integer; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
  395.         var
  396.             oe, ooe: OSErr;
  397.             cbp: MyControlBlockPtr;
  398.             cb: TCPControlBlock;
  399.     begin
  400.         oe := CreateStream(connection, buffersize);
  401.         if oe = noErr then begin
  402.             with connection^ do begin
  403.                 oe := GetCB(cbp, connection, cs, userptr, nil);
  404.                 if oe = noErr then begin
  405.                     cbp^.tcp.open.localPort := localPort;
  406.                     cbp^.tcp.open.remoteHost := remoteIP;
  407.                     cbp^.tcp.open.remotePort := remoteport;
  408.                     oe := MyPBControlAsync(cbp);
  409.                 end;
  410.                 if oe <> noErr then begin
  411.                     ZeroCB(cb, stream, TCPcsRelease);
  412.                     ooe := PBControlSync(@cb);
  413.                     DestroyConnection(connection);
  414.                 end;
  415.             end;
  416.         end;
  417.         SetUserPtr(userptr, oe);
  418.         PAOpen := oe;
  419.     end;
  420.  
  421. { Open a connection to another machine }
  422.     function TCPActiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
  423.     begin
  424.         TCPActiveOpen := PAOpen(connection, TCPcsActiveOpen, buffersize, localport, remoteIP, remoteport, userptr);
  425.     end;
  426.  
  427. { Open a socket on this machine, to wait for a connection }
  428.     function TCPPassiveOpen (var connection: TCPConnectionPtr; buffersize: longInt; localport: integer; remoteIP: longInt; remoteport: integer; userptr: OSErrPtr): OSErr;
  429.     begin
  430.         TCPPassiveOpen := PAOpen(connection, TCPcsPassiveOpen, buffersize, localport, remoteIP, remoteport, userptr);
  431.     end;
  432.  
  433.     function TCPRawReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
  434. { Return readCount characters from the TCP connection. }
  435. { WARNING: Doesnt handle incoming buffer, so don't use with TCPReceiveUptp or ReadByte }
  436.         var
  437.             cb: TCPControlBlock;
  438.             oe: OSErr;
  439.     begin
  440.         repeat
  441.             ZeroCB(cb, connection^.stream, TCPcsRcv);
  442.             cb.receive.rcvBuff := returnPtr;
  443.             cb.receive.rcvBuffLength := readCount;
  444.             oe := PBControlSync(@cb);
  445.             longInt(returnPtr) := longInt(returnPtr) + cb.receive.rcvBuffLength;
  446.             readCount := readCount - cb.receive.rcvBuffLength;
  447.         until (oe <> noErr) or (readCount = 0);
  448.         TCPRawReceiveChars := oe;
  449.     end;
  450.  
  451. { Return readCount characters from the TCP connection.}
  452.     function TCPReceiveChars (connection: TCPConnectionPtr; returnPtr: ptr; readCount: integer): OSErr;
  453.         var
  454.             readCountStr: Str255;
  455.             l: longInt;
  456.             p: Ptr;
  457.             oe: OSErr;
  458.             cb: TCPControlBlock;
  459.     begin
  460.         oe := ValidateConnection(connection);
  461.         if oe = noErr then
  462.             if readCount < 0 then
  463.                 oe := invalidLength
  464.             else if readCount > 0 then begin
  465.                 p := returnPtr;
  466.                 with connection^ do
  467.                     if incomingSize > 0 then begin
  468.             { Read as much as there is or as much as we need, whichever is less. }
  469.                         if readCount < incomingSize then
  470.                             l := readCount
  471.                         else
  472.                             l := incomingSize;
  473.                         BlockMove(incomingPtr, p, l);
  474.                         incomingPtr := Ptr(ord4(incomingPtr) + l);
  475.                         incomingSize := incomingSize - l;
  476.                         p := Ptr(ord4(p) + l);
  477.                         readCount := readCount - l;
  478.                     end;
  479.                 { If there's more needed, then read it from the connection. }
  480.                 if readCount > 0 then begin
  481.                         { Issue a read and wait until it all arrives). }
  482.                     oe := TCPRawReceiveChars(connection, p, readCount);
  483.                 end;
  484.             end;
  485.         TCPReceiveChars := oe;
  486.     end;
  487.  
  488.     function TCPReadByte (connection: TCPConnectionPtr; timeout: longInt; var b: SignedByte): OSErr;
  489.         { Return the next byte in the buffer, reading more in if necessary. }
  490.         var
  491.             waitUntil: longInt;
  492.             readIn: longInt;
  493.             oe: OSErr;
  494.             cb: TCPControlBlock;
  495.     begin
  496.         oe := ValidateConnection(connection);
  497.         if oe = noErr then
  498.             with connection^ do begin            { Check if we need to read in more bytes. }
  499.                 if incomingSize = 0 then begin
  500.                     if (timeout = 0) and (TCPCharsAvailable(connection) = 0) then
  501.                         oe := commandTimeout
  502.                     else begin
  503.                         waitUntil := TickCount + timeout;
  504.     { keep on trying to read until we get at least one, or the time-out happens. }
  505.                         while (oe = noErr) and (incomingSize = 0) do begin                { Get the status. }
  506.                             readIn := TCPCharsAvailable(connection);    { If there's something there to read, do so. }
  507.                             if readIn > 0 then begin    { Don't read any more than will fit in the buffer. }
  508.                                 if readIn > INCOMINGBUFSIZE then
  509.                                     readIn := INCOMINGBUFSIZE;
  510.                         { Issue the read. }
  511.                                 oe := TCPRawReceiveChars(connection, @inBuf, readIn);
  512.                                 if oe = noErr then begin
  513.                                     incomingSize := readIn;
  514.                                     incomingPtr := @inBuf;
  515.                                 end;
  516.                             end        { If not, do another round or get out, depending on the timeout condition. }
  517.                             else if TickCount > waitUntil then begin
  518.                                 oe := commandTimeOut;
  519.                             end;
  520.                         end;
  521.                     end;
  522.                 end;
  523.                 { Get the byte to return. }
  524.                 if incomingSize > 0 then begin
  525.                     b := incomingPtr^;
  526.                     incomingPtr := Ptr(ord4(incomingPtr) + 1);
  527.                     incomingSize := incomingSize - 1;
  528.                 end
  529.                 else
  530.                     b := 0;
  531.             end;
  532.         TCPReadByte := oe;
  533.     end;
  534.  
  535. { Pass in a block of memory (readPtr,readSize), already containing readPos bytes}
  536. { TCPReceiveUpTo will then read characters until a termChar character is reached,}
  537. { or until waitForChars ticks go by without receiving any bytes.  If waitForChars is}
  538. { zero, then TCPReceiveUpTo will return immediately.  If termChar=0, then it}
  539. { will read the entire buffer, and any characters that arrive before a timeout }
  540.     function TCPReceiveUpTo (connection: TCPConnectionPtr; termChar: signedByte;{}
  541.                                     charTimeOut: longInt; readPtr: ptr; readSize: longInt; var readPos: longInt;{}
  542.                                     var gottermchar: boolean): OSErr;
  543.         var
  544.             oe: OSErr;
  545.             inChar: SignedByte;
  546.             p: Ptr;
  547.     begin
  548.         oe := ValidateConnection(connection);
  549.         gottermchar := false;
  550.         if oe = noErr then begin
  551. { Cycle until the timeout happens or we see the termintor character or we run out of room. }
  552.             while (oe = noErr) and (readPos < readSize) and not gottermchar do begin            { Get the next character. }
  553.                 oe := TCPReadByte(connection, charTimeOut, inChar);                    { Ignore the character if it's a zero. }
  554.                 if (oe = noErr) and (inChar <> 0) then begin            { Put it in the result. }
  555.                     p := Ptr(ord4(readPtr) + readPos);
  556.                     p^ := inChar;
  557.                     readPos := readPos + 1;
  558.                     gottermchar := inChar = termChar;
  559.                 end;
  560.             end;
  561.             if oe = commandTimeOut then
  562.                 oe := noErr;
  563.         end;
  564.         TCPReceiveUpTo := oe;
  565.     end;
  566.  
  567.     function TCPSend (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean): OSErr;
  568.         var
  569.             wds: wdsType;
  570.             oe: OSErr;
  571.             cb: TCPControlBlock;
  572.             p: ptr;
  573.     begin
  574.         oe := ValidateConnection(connection);
  575.         if oe = nOErr then
  576.             if writeCount > 0 then begin
  577.                 wds.buffer := writePtr;
  578.                 wds.size := writeCount;
  579.                 wds.term := 0;
  580.                 ZeroCB(cb, connection^.stream, TCPcsSend);
  581.                 cb.send.wds := @wds;
  582.                 cb.send.pushFalg := ord(push);
  583.                 oe := PBControlSync(@cb);
  584.             end
  585.             else if writeCount < 0 then
  586.                 oe := InvalidLength;
  587.         TCPSend := oe;
  588.     end;
  589.  
  590. {$PUSH}
  591. {$D-}
  592.     procedure TCPSendComplete (cbp: MyControlBlockPtr);
  593.         var
  594.             oe: OSErr;
  595.     begin
  596.         AddBlock(cbp^.tcp.send.wds);
  597.         with cbp^.tcpc^ do begin
  598.             asendcompletes := asendcompletes + 1;
  599.             if (asendcompletes = asends) and closedone then begin
  600.                 oe := GetCB(cbp, cbp^.tcpc, TCPcsClose, closeuserptr, nil);
  601. { GetCB won't NewPtr because the completion has just released a block }
  602.                 if oe = noErr then begin
  603.                     oe := MyPBControlAsync(cbp);
  604.                 end;
  605.             end;
  606.         end;
  607.     end;
  608. {$POP}
  609.  
  610.     function TCPSendAsync (connection: TCPConnectionPtr; writePtr: ptr; writeCount: integer; push: boolean; userptr: OSErrPtr): OSErr;
  611.         type
  612.             myblock = record
  613.                     wds: wdsType;
  614.                     data: array[0..100] of byte;
  615.                 end;
  616.             myblockptr = ^myblock;
  617.         var
  618.             oe: OSErr;
  619.             cbp: MyControlBlockPtr;
  620.             p: myblockptr;
  621.     begin
  622.         oe := ValidateConnection(connection);
  623.         if oe = nOErr then
  624.             if writeCount > 0 then begin
  625.                 p := myblockptr(NewPtr(writeCount + SizeOf(wdsType)));
  626.                 if p = nil then
  627.                     oe := memFullErr
  628.                 else begin
  629.                     p^.wds.buffer := @p^.data;
  630.                     p^.wds.size := writeCount;
  631.                     p^.wds.term := 0;
  632.                     with p^.wds do
  633.                         BlockMove(writePtr, buffer, size);
  634.                     oe := GetCB(cbp, connection, TCPcsSend, userptr, @TCPSendComplete);
  635.                     cbp^.tcp.send.wds := POINTER(p);
  636.                     cbp^.tcp.send.pushFalg := ord(push);
  637.                     with connection^ do
  638.                         asends := asends + 1;
  639.                     oe := MyPBControlAsync(cbp);
  640.                     if oe <> noErr then
  641.                         DisposPtr(ptr(p));
  642.                 end;
  643.             end
  644.             else if writeCount < 0 then
  645.                 oe := InvalidLength;
  646.         TCPSendAsync := oe;
  647.     end;
  648.  
  649.     function TCPClose (connection: TCPConnectionPtr; userptr: OSErrPtr): OSErr;
  650.         var
  651.             oe: OSErr;
  652.             cbp: MyControlBlockPtr;
  653.     begin
  654.         oe := ValidateConnection(connection);
  655.         if oe = noErr then
  656.             with connection^ do begin
  657.                 closeuserptr := userptr;
  658.                 if userptr <> nil then
  659.                     userptr^ := inProgress;
  660.                 closedone := true;
  661.                 if asends = asendcompletes then begin
  662.                     oe := GetCB(cbp, connection, TCPcsClose, userptr, nil);
  663.                     if oe = noErr then begin
  664.                         oe := MyPBControlAsync(cbp);
  665.                     end;
  666.                 end;
  667.             end;
  668.         SetUserPtr(userptr, oe);
  669.         TCPClose := oe;
  670.     end;
  671.  
  672.     function TCPAbort (connection: TCPConnectionPtr): OSErr;
  673.         var
  674.             oe: OSErr;
  675.             cb: TCPControlBlock;
  676.     begin
  677.         oe := ValidateConnection(connection);
  678.         if oe = noErr then begin
  679.             ZeroCB(cb, connection^.stream, TCPcsAbort);
  680.             oe := PBControlSync(@cb);
  681.         end;
  682.         TCPAbort := oe;
  683.     end;
  684.  
  685. { Release the TCP stream, including the buffer.}
  686.     function TCPRelease (var connection: TCPConnectionPtr): OSErr;
  687.         var
  688.             oe: OSErr;
  689.             cb: TCPControlBlock;
  690.     begin
  691.         oe := ValidateConnection(connection);
  692.         if oe = noErr then begin
  693.             ZeroCB(cb, connection^.stream, TCPcsRelease);
  694.             oe := PBControlSync(@cb);
  695.             DestroyConnection(connection);
  696.         end;
  697.         TCPRelease := oe;
  698.     end;
  699.  
  700. {    TCPRawState(connectionID) -- Return the state of the TCP connection.}
  701.     procedure TCPRawState (connection: TCPConnectionPtr; var state: integer; var localhost: longInt; var localport: integer; var remotehost: longInt; var remoteport: integer; var available: longInt);
  702.         var
  703.             cb: TCPControlBlock;
  704.             oe: OSErr;
  705.     begin
  706.         oe := ValidateConnection(connection);
  707.         localhost := 0;
  708.         localport := 0;
  709.         remotehost := 0;
  710.         remoteport := 0;
  711.         available := 0;
  712.         if oe <> noErr then begin
  713.             state := 99; { Error -> Closed }
  714.         end
  715.         else begin
  716.             ZeroCB(cb, connection^.stream, TCPcsStatus);
  717.             if PBControlSync(@cb) <> noErr then begin
  718.                 state := 99; { Closed }
  719.             end
  720.             else begin
  721.                 state := cb.status.connectionState;
  722.                 connection^.laststate := state;
  723.                 localhost := cb.status.localhost;
  724.                 localport := cb.status.localport;
  725.                 remotehost := cb.status.remotehost;
  726.                 remoteport := cb.status.remoteport;
  727.                 available := cb.status.amtUnreadData + connection^.incomingSize;
  728.             end;
  729.         end;
  730.     end;
  731.  
  732. { Return the state of the TCP connection.}
  733.     function TCPState (connection: TCPConnectionPtr): TCPStateType;
  734.         var
  735.             state: integer;
  736.             localhost: longInt;
  737.             localport: integer;
  738.             remotehost: longInt;
  739.             remoteport: integer;
  740.             available: longInt;
  741.     begin
  742.         TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
  743.         case state of
  744.             0: 
  745.                 TCPState := T_Closed;
  746.             2: 
  747.                 TCPState := T_Listening;
  748.             4, 6: 
  749.                 TCPState := T_Opening;
  750.             8: 
  751.                 TCPState := T_Established;
  752.             10, 12, 16, 18, 20: 
  753.                 TCPState := T_Closing;
  754.             14: 
  755.                 TCPState := T_PleaseClose;
  756.             98: 
  757.                 TCPState := T_WaitingForOpen;
  758.             99: 
  759.                 TCPState := T_Closed;
  760.             otherwise
  761.                 TCPState := T_Unknown;
  762.         end;
  763.     end;
  764.  
  765. {    Return the number of characters available for reading from the TCP connection.}
  766.     function TCPCharsAvailable (connection: TCPConnectionPtr): longInt;
  767.         var
  768.             state: integer;
  769.             localhost: longInt;
  770.             localport: integer;
  771.             remotehost: longInt;
  772.             remoteport: integer;
  773.             available: longInt;
  774.     begin
  775.         TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
  776.         TCPCharsAvailable := available;
  777.     end;
  778.  
  779.     function TCPLocalPort (connection: TCPConnectionPtr): integer;
  780.         var
  781.             state: integer;
  782.             localhost: longInt;
  783.             localport: integer;
  784.             remotehost: longInt;
  785.             remoteport: integer;
  786.             available: longInt;
  787.     begin
  788.         TCPRawState(connection, state, localhost, localport, remotehost, remoteport, available);
  789.         TCPLocalPort := localport;
  790.     end;
  791.  
  792.     function TCPFlush (connection: TCPConnectionptr): OSErr;
  793.         var
  794.             buffer: array[0..255] of signedByte;
  795.             f: longInt;
  796.             oe: OSErr;
  797.     begin
  798.         f := TCPCharsAvailable(connection);
  799.         oe := noErr;
  800.         while (f > 0) and (oe = noErr) do begin
  801.             if f > 256 then
  802.                 f := 256;
  803.             oe := TCPReceiveChars(connection, @buffer, f);
  804.             if oe = noErr then
  805.                 f := TCPCharsAvailable(connection);
  806.         end;
  807.         TCPFlush := oe;
  808.     end;
  809.  
  810.     procedure UDPZeroCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);
  811.     { Zero out the control block parameters. }
  812.         var
  813.             i: integer;
  814.             p: longInt;
  815.     begin
  816.         for p := longInt(@cb) to longInt(@cb) + SizeOf(UDPControlBlock) - 1 do
  817.             ptr(p)^ := 0;
  818.         cb.udpStream := stream;
  819.         cb.ioCRefNum := driver_refnum;
  820.         cb.csCode := call;
  821.     end;
  822.  
  823.     procedure MyNotify (stream: streamPtr; eventCode: integer; connection: UDPConnectionPtr; icmpMsg: ptr);
  824.     begin
  825.         if eventCode = UDPDataArrival then
  826.             if connection^.magic = UDPMagic then
  827.                 connection^.outstanding := connection^.outstanding + 1;
  828.     end;
  829.  
  830.     function UDPCreate (var connection: UDPConnectionPtr; buffer_size: longInt; var localport: integer): OSErr;
  831.         var
  832.             oe: OSErr;
  833.             cb: UDPControlBlock;
  834.     begin
  835.         if buffer_size = 0 then
  836.             buffer_size := Default_UDPBufferSize;
  837.         connection := UDPConnectionPtr(NewPtr(SizeOf(UDPConnectionRecord) + buffer_size));
  838.         oe := MemError;
  839.         if connection <> nil then begin
  840.             connection^.magic := UDPMagic;
  841.             UDPZeroCB(cb, nil, UDPcsCreate);
  842.             cb.create.rcvBuff := ptr(longInt(connection) + SizeOf(UDPConnectionRecord));
  843.             cb.create.rcvBuffLen := buffer_size;
  844.             cb.create.notifyProc := @MyNotify;
  845.             cb.create.userDataPtr := ptr(connection);
  846.             cb.create.localport := localport;
  847.             oe := PBControlSync(@cb);
  848.             localport := cb.create.localport;
  849.             connection^.stream := cb.udpStream;
  850.             connection^.outstanding := 0;
  851.         end;
  852.         UDPCreate := oe;
  853.     end;
  854.  
  855.     function UDPRead (connection: UDPConnectionPtr; timeout: integer; var remoteIP: longInt; var remoteport: integer;{}
  856.                                     var datap: ptr; var datalen: integer): OSErr;
  857.         var
  858.             oe: OSErr;
  859.             cb: UDPControlBlock;
  860.     begin
  861.         UDPZeroCB(cb, connection^.stream, UDPcsRead);
  862.         cb.receive.timeout := timeout;
  863.         oe := PBControlSync(@cb);
  864.         if oe = noErr then
  865.             connection^.outstanding := connection^.outstanding - 1;
  866.         remoteIP := cb.receive.remoteIP;
  867.         remoteport := cb.receive.remoteport;
  868.         datap := cb.receive.rcvBuff;
  869.         datalen := cb.receive.rcvBuffLen;
  870.         UDPRead := oe;
  871.     end;
  872.  
  873.     function UDPReturnBuffer (connection: UDPConnectionPtr; datap: ptr): OSErr;
  874.         var
  875.             oe: OSErr;
  876.             cb: UDPControlBlock;
  877.     begin
  878.         UDPZeroCB(cb, connection^.stream, UDPcsBfrReturn);
  879.         cb.return.rcvBuff := datap;
  880.         oe := PBControlSync(@cb);
  881.         UDPReturnBuffer := oe;
  882.     end;
  883.  
  884.     function UDPDatagramsAvailable (connection: UDPConnectionPtr): integer;
  885.     begin
  886.         UDPDatagramsAvailable := connection^.outstanding;
  887.     end;
  888.  
  889.     function UDPWrite (connection: UDPConnectionPtr; remoteIP: longInt; remoteport: integer;{}
  890.                                     datap: ptr; datalen: integer; checksum: boolean): OSErr;
  891.         var
  892.             oe: OSErr;
  893.             cb: UDPControlBlock;
  894.             wds: wdsType;
  895.     begin
  896.         UDPZeroCB(cb, connection^.stream, UDPcsWrite);
  897.         cb.send.remoteIP := remoteIP;
  898.         cb.send.remotePort := remoteport;
  899.         wds.size := datalen;
  900.         wds.buffer := datap;
  901.         wds.term := 0;
  902.         cb.send.wds := @wds;
  903.         cb.send.checksum := ord(checksum);
  904.         oe := PBControlSync(@cb);
  905.         UDPWrite := oe;
  906.     end;
  907.  
  908.     function UDPRelease (var connection: UDPConnectionPtr): OSErr;
  909.         var
  910.             oe: OSErr;
  911.             cb: UDPControlBlock;
  912.     begin
  913.         UDPZeroCB(cb, connection^.stream, UDPcsRelease);
  914.         oe := PBControlSync(@cb);
  915.         connection^.magic := UDPBad;
  916.         DisposPtr(ptr(connection));
  917.         UDPRelease := oe;
  918.     end;
  919.  
  920.     function UDPMTU (remoteIP: longInt; var mtu: integer): OSErr;
  921.         var
  922.             oe: OSErr;
  923.             cb: UDPControlBlock;
  924.     begin
  925.         UDPZeroCB(cb, nil, UDPcsMaxMTUSize);
  926.         cb.mtu.remoteIP := remoteIP;
  927.         oe := PBControlSync(@cb);
  928.         mtu := cb.mtu.mtuSize;
  929.         UDPMTU := oe;
  930.     end;
  931.  
  932.     procedure IPZeroCB (var cb: IPControlBlock; call: integer);
  933.     { Zero out the control block parameters. }
  934.         var
  935.             i: integer;
  936.             p: longInt;
  937.     begin
  938.         for p := longInt(@cb) to longInt(@cb) + SizeOf(cb) - 1 do
  939.             ptr(p)^ := 0;
  940.         cb.ioCRefNum := driver_refnum;
  941.         cb.csCode := call;
  942.     end;
  943.  
  944.     procedure IPCallCompletion (cbp: IPControlBlockPtr; userdata, extradata: ptr; addr: procPtr);
  945.     inline
  946.         $205F, $4E90;
  947.  
  948. {$PUSH}
  949. {$D-}
  950.     procedure IPICMPCompletion; { All C functions look like pascal paramterless procedures from the procs point of view }
  951.         type
  952.             stackframe = packed record
  953.                     frameptr: ptr;
  954.                     returnptr: ptr;
  955.                     paramblockptr: IPControlBlockPtr;
  956.                 end;
  957.             stackframeptr = ^stackframe;
  958.         var
  959.             a6: stackframeptr;
  960.             cbp: IPControlBlockPtr;
  961.             index: integer;
  962.     begin
  963.         a6 := stackframeptr(GetA6);
  964.         cbp := a6^.paramblockptr;
  965.         icmp_got_back := icmp_got_back + 1;
  966.         with cbp^.echoinfo do begin
  967.             index := ord(userDataPtr);
  968.             if (index > 0) & (icmp_data_array[index].complete <> nil) then begin
  969.                 IPCallCompletion(cbp, icmp_data_array[index].userdata, icmp_data_array[index].extradata, icmp_data_array[index].complete);
  970.                 icmp_data_array[index].complete := nil;
  971.             end;
  972.         end;
  973.     end;
  974. {$POP}
  975.  
  976.     function IPSendICMPEcho (remotehost: ipAddr; timeout: integer; datap: ptr; datalen: integer; complete: ProcPtr; userdata: univ ptr; extradata: univ ptr): OSErr;
  977.         var
  978.             cb: IPControlBlock;
  979.             i, index: integer;
  980.             oe: OSErr;
  981.     begin
  982.         index := -1;
  983.         if complete <> nil then begin
  984.             for i := 1 to max_ICMPDataArray do begin
  985.                 if icmp_data_array[i].complete = nil then begin
  986.                     index := i;
  987.                     icmp_data_array[i].complete := complete;
  988.                     icmp_data_array[i].userdata := userdata;
  989.                     icmp_data_array[i].extradata := extradata;
  990.                     leave;
  991.                 end;
  992.             end;
  993.         end;
  994.         IPZeroCB(cb, TCPcsEchoICMP);
  995.         cb.echo.dest := remotehost;
  996.         cb.echo.data.buffer := datap;
  997.         cb.echo.data.size := datalen;
  998.         cb.echo.timeout := timeout;
  999.         cb.echo.options := nil;
  1000.         cb.echo.optlength := 0;
  1001.         cb.echo.icmpCompletion := @IPICMPCompletion;
  1002.         cb.echo.userDataPtr := ptr(index);
  1003.         oe := PBControlSync(@cb);
  1004.         if oe = noErr then
  1005.             icmp_sent_out := icmp_sent_out + 1;
  1006.         IPSendICMPEcho := oe;
  1007.     end;
  1008.  
  1009.     function IPGetMyIPAddr (var myIP: longInt): OSErr;
  1010.         var
  1011.             cb: IPControlBlock;
  1012.             oe: OSErr;
  1013.     begin
  1014.         IPZeroCB(cb, TCPcsGetMyIP);
  1015.         oe := PBControlSync(@cb);
  1016.         myIP := cb.getmyip.ourAddress;
  1017.         IPGetMyIPAddr := oe;
  1018.     end;
  1019.  
  1020.  
  1021. end.